\
\ Some compatiblity to 4p coded in ANS-like Forth.
\
\ It is very experimental and incomplete at the moment.
\ Not much tests where done with gforth and pforth.
\ It runs with 4p if you turn of the JIT (option -J).
\
\ For documentation see: http://maschenwerk.de/4p/control-flow.txt
\
\ Author: Helmar Wodtke
\
1024 CONSTANT /CNONAMES
: `              POSTPONE POSTPONE ;                              IMMEDIATE
: BUFFER         CREATE ALLOT ;
 /CNONAMES CELLS BUFFER   CNONAMES
                 VARIABLE CN          CNONAMES CN !
        16 CELLS BUFFER   CNSTACK
                 VARIABLE CNS         CNSTACK CNS !
                 VARIABLE CRH
         1 CELLS CONSTANT 1#C
        -1 CELLS CONSTANT -1#C
       256 CELLS BUFFER   ELSE-STACK
                 VARIABLE ELSE?       ELSE-STACK 1#C - ELSE? !
                 VARIABLE IFDEPTH
       256 CELLS BUFFER BEGIN-IFS
                 VARIABLE BEGINS      BEGIN-IFS BEGINS !
: ??             ` IF ' COMPILE, ` THEN ;                         IMMEDIATE
: !EXECUTE       >R ;
: ?EXECUTE       STATE @ IF ` LITERAL ` !EXECUTE EXIT
                 THEN >R ;
: ?LITERAL       STATE @ IF ` LITERAL THEN ;
: BODY,          >BODY ?LITERAL ;
: THEN>          R> ?EXECUTE ;
: LATER>         R> R> SWAP >R >R ;
: >CNS           CNS @ ! 1#C CNS +! ;
: CNS>           -1#C CNS +! CNS @ @ ;
: >CRH           CRH @ IF SWAP EXECUTE CRH @ ! THEN CRH ! ;
: (C{)           R> SWAP @ >R ;
: (>DXT)         R> ;
: (NOOP)         (>DXT) ;
: (NN)           :NONAME ` (>DXT) RDROP ;
: C{             STATE @ 0= IF 0 >CNS (NN) THEN
                 1#C CN DUP @ DUP >CNS ` LITERAL +! ` (C{) ;      IMMEDIATE
: }              ` ; CNS> >CRH CNS @ @ ?? (NN) EXECUTE ;          IMMEDIATE
: ;              ` ; 0 >CRH ;                                     IMMEDIATE
: },             ` } STATE @ IF ` ?EXECUTE EXIT THEN >R ;         IMMEDIATE
: DEFER          CREATE (NOOP) , DOES> @ >R ;
: LIKE           ' BODY, THEN> @ ;                                IMMEDIATE
: IS             ' BODY, THEN> ! ;                                IMMEDIATE
: }:             [ IMMEDIATE ] ` } STATE @ 0= IF ` IS EXIT THEN ' BODY,
                 C{ R> -ROT DUP >R DUP @ >R ! C{ R> R> ! } >R >R }, ;
: (REPEAT)       >R BEGIN R@ !EXECUTE AGAIN ;
: RNDROP         R> SWAP BEGIN ?DUP WHILE RDROP 1- REPEAT >R ;
: +BEGINS        IFDEPTH @ BEGINS @ ! 1#C BEGINS +! ;
: -BEGINS        -1#C BEGINS +! ;
: LOOP-RDEPTH    IFDEPTH @ BEGINS @ 1#C - @ - ;
: DEF-RDEPTH     BEGINS @ BEGIN-IFS - 1#C / 3 * IFDEPTH @ + ;
                 VARIABLE (RPUT)
: RPUT           1+ DUP 1+ (RPUT) ! BEGIN ?DUP WHILE R> -ROT 1- REPEAT
                 (RPUT) @ BEGIN ?DUP WHILE SWAP >R 1- REPEAT ;
: RGET           1+ DUP 1+ BEGIN ?DUP WHILE R> -ROT 1- REPEAT
                 BEGIN ?DUP WHILE ROT >R 1- REPEAT ;
: BEGIN          +BEGINS ` C{ ;                                   IMMEDIATE
: REPEAT         -BEGINS ` } ` (REPEAT) ;                         IMMEDIATE
: LEAVE          LOOP-RDEPTH 2 + ` LITERAL ` RNDROP ` EXIT ;      IMMEDIATE
: WHILE          ` 0= ` IF ` LEAVE ` THEN ;                       IMMEDIATE
: WHILE:         ` BEGIN ` ?DUP ` WHILE ;                         IMMEDIATE
: >LATER         DEF-RDEPTH ?DUP IF ` LITERAL ` RPUT EXIT
                 THEN ` >R ;                                      IMMEDIATE
: (ELSE-THEN)    ROT ?? SWAP >R DROP ;
: (THEN)         SWAP IF >R EXIT THEN DROP ;
: >R             ` >LATER ;                                       IMMEDIATE
: R>             DEF-RDEPTH ?DUP IF ` LITERAL ` RGET EXIT
                 THEN ` R> ;                                      IMMEDIATE
: R              ` R> ` DUP ` >R ;                                IMMEDIATE
: R@             ` R ;                                            IMMEDIATE
: RDROP          ` R> ` DROP ;                                    IMMEDIATE
: EXIT           DEF-RDEPTH ?DUP IF ` LITERAL ` RNDROP
                 THEN ` EXIT ;                                    IMMEDIATE
: OR:            ` IF ` EXIT ` THEN ;                             IMMEDIATE
: AND:           ` 0= ` OR: ;                                     IMMEDIATE
: 0;             ` ?DUP ` AND: ;                                  IMMEDIATE
: ;;             ` EXIT ;                                         IMMEDIATE
: THEN           ` } ELSE? @ @ IF ` (ELSE-THEN) ELSE ` (THEN)
                 THEN -1#C ELSE? +! -1 IFDEPTH +! ;               IMMEDIATE
: IF             1 IFDEPTH +! 1#C ELSE? +! ELSE? @ OFF ` C{ ;     IMMEDIATE
: ELSE           ` } ` C{ ELSE? @ ON ;                            IMMEDIATE
: ;THEN          ` EXIT ` THEN ;                                  IMMEDIATE

\ ---------------- testcases ----------------

CR CR .( You should see similar lines:) CR CR

.( Hello World!) CR
C{ ." Hello World!" CR }, CR

: test1 3 BEGIN ?DUP WHILE 1- C{ ." B " } >LATER ." A " REPEAT ;

.( A A A B B B ) CR
test1 CR CR

DEFER test2
C{ ." A " } IS test2
: test3 test2 test2 C{ ." B " }: test2 test2 test2 ;

.( A A B B A A ) CR
test3 test2 test2 CR CR

: test4 IF ." A " ELSE ." B " THEN ." C " ;

.( A C B C A C ) CR
1 test4 0 test4 1 test4 CR CR

: test5 BEGIN ?DUP WHILE ." A " 1- DUP 10 < WHILE 1- ." B " REPEAT ." C " ;

.( A B A B C A C ) CR
4 test5 100 test5 CR CR

: test6 ." A " THEN> ." B " ;
: test7 test6 test6 test6 ;

.( A B A B A B ) CR
test7 CR CR

: test8 test7 ; IMMEDIATE

.( A A A B B B ) CR
: test9 test8 ; test9 CR CR

